perm filename PL0.PAS[PAS,SYS] blob
sn#329935 filedate 1978-09-07 generic text, type T, neo UTF8
00100 program pl0(input,output);
00200 (*pl/0 compiler with code generation*)
00300 label 99;
00400 CONST NORW = 20;
00500 type symbol =
00600 (nul,ident,number,plus,minus,times,slash,oddsym,QUOTE,
00700 eql,neq,lss,leq,gtr,geq,lparen,rparen,comma,semicolon,COLON,
00800 period,becomes,EXP,beginsym,endsym,ifsym,thensym,ELSESYM,
00900 whilesym,dosym,callsym,constsym,varsym,procsym,ODDSYM,
01000 REPEATSYM,UNTILSYM,FORSYM,TOSYM,BYSYM,WRITESYM,READSYM,
01100 FUNCTSYM);
01200
01300 alfa = packed array [1..al] of char;
01400 object = (constant,variable,procedure,FUNCTION);
01500 symset = set of symbol;
01600 fct = (lit,opr,lod,sto,cal,int,jmp,jpc,DIN,DOT,LDI,STI); (*functions*)
01700 instruction = packed record
01800 f: fct; (*function code*)
01900 l: 0..levmax; (*level*)
02000 a: 0..amax; (*displacement address*)
02100 end;
02200 (* lit 0,a : load constant a
02300 opr 0,a : execute operation a
02400 lod l,a : load variable a
02500 sto l,a : store variable l,a
02600 cal l,a : call procedure a at level l
02700 int 0,a : increment t-register by a
02800 jmp 0,a : jump to a
02900 jpc 0,a : jump conditional to a
03000 DIN 0,0 : READ DATA INTO STACK
03100 DOT 0,0 : WRITE DATA FROM STACK
03200 LDI L,0 : LOAD STACK INDIRECTLY
03300 STI L,0 : STORE FROM STACK INDIRECTLY *)
03400
03500 var ch: char; (*last character read*)
03600 sym: symbol; (*last symbol read*)
03700 id: alfa; (*last identifier read*)
03800 num : integer; (*last number read*)
03900 cc: integer; (*character count*)
04000 ll: integer; (*line length*)
04100 kk: integer;
04200 cx: integer; (*code allocation index*)
04300 line: array[1..81] of char;
04400 a: alfa;
04500 code: array[0..cxmax] of instruction;
04600 word: array[1..norw] of alfa;
04700 wsym: array[1..norw] of symbol;
04800 ssym: array[char] of symbol;
04900 mnemonic: array[fct] of packed array[1..5] of char;
05000 declbegsys, statbegsys, facbegsys: symset;
05100
05200 table: array[0..txmax] of
05300 record name: alfa;
05400 case kind: object of
05500 constant: (val,integer);
05600 variable: (level,adr,LOW,HIGH: integer);
05700 procedure,FUNCTION: (level,adr,NPARAM: integer)
05800 end;
05900
06000 procedure error(n: integer);
06100 begin writeln(' ****',' ': cc-1, '↑', n: 2);
06200 end (*error*);
06300
06400 procedure getsym;
06500 var i,j,k: integer;
06600
06700 procedure getch;
06800 begin if cc = ll then
06900 begin if eof(input) then
07000 begin write('program incomplete'); goto 99
07100 end;
07200 ll := 0; cc := 0; write(cx: 5, ' ');
07300 while /eoln(input) do
07400 begin ll := ll+1; read(ch); write (ch); line[ll] := ch
07500 end;
07600 writeln;
07700 ll := ll+1; read(line[ll])
07800 end;
07900 cc := cc+1; ch := line[cc]
08000 end (*getch*);
08100
08200 begin (*getsym*)
08300 while ch = ' ' do getch
08400 if ch in ['a'..'z'] then
08500 begin (*identifier or reserved word*) k := 0;
08600 repeat if k<al then
08700 begin k := k+1; a[k] := ch
08800 end;
08900 getch
09000 until /(ch in ['a'..'z','0'..'9']);
09100 if k >= kk then kk := k else
09200 repeat a[kk] := ' '; kk := kk-1
09300 until kk := k;
09400 id := a, i := 1, j := norw;
09500 repeat k := (i+j) div 2;
09600 if id =< word[k] then j := k-1;
09700 if id >= word[k] then i := k+1
09800 until i > j;
09900 if i-1 > j then sym := wsym[k] else sym := ident
10000 end else
10100 if ch in ['0'..'9'] then
10200 begin (*number*) k := 0; num := 0; sym := number;
10300 repeat num := 10*num + (ord(ch) - ord('0'));
10400 k := k+1; getch
10500 until /(ch in ['0'..'9']);
10600 if k > nmax then error(30)
10700 end else
10800 if ch = ':' then
10900 begin getch;
11000 if ch = '=' then
11100 begin sym := becomes, getch
11200 end else sym := COLON;
11300 end else
11400 begin sym := ssym[ch]; getch
11500 end
11600 end (*getsym*)
11700
11800 procedure gen(x: fct; y,z: integer);
11900 begin if cx > cxmax then
12000 begin write('program too long'); goto 99
12100 end;
12200 with code[cx] do
12300 begin f := x; l := y; a := z
12400 end;
12500 cx := cx + 1
12600 end (*gen*);
12700
12800 procedure test(s1,s2: symset; n: integer);
12900 begin if /(sym in s1) then
13000 begin error(n); s1 := s1 + s2;
13100 while /(sym in s1) do getsym
13200 end
13300 end (*test*);
13400
13500 procedure block(lev,tx: integer; fsys: symset);
13600 var dx: integer; (*data allocation index*)
13700 tx0: integer; (*initial table index*)
13800 cx0: integer; (*initial code index*)
13900
14000
14100 procedure enter(k:object);
14200 begin (*enter object into table*)
14300 tx := tx+1;
14400 with table[tx] do
14500 begin name := id; kind := k;
14600 case k of
14700 constant: begin if num > amax then
14800 begin error(31); num := 0 end;
14900 val := num
15000 end;
15100 variable: begin IF DX =< 0 THEN LEVEL := LEV+1 ELSE level := lev; adr := dx; dx := dx+1;
15200 GETSYM;
15300 IF SYM = LPAREN THEN
15400 BEGIN
15500 GETSYM; TEST([CONSTANT],[COLON,RPAREN]+FSYS,32);
15600 IF SYM = CONSTANT THEN
15700 BEGIN LOW := NUM; GETSYM
15800 END;
15900 IF SYM = COLON THEN GETSYM ELSE ERROR(32);
16000 TEST([CONSTANT],[RPAREN]+FSYS,32);
16100 IF SYM = CONSTANT THEN
16200 BEGIN HIGH := NUM; GETSYM;
16300 DX := DX + HIGH - LOW
16400 END;
16500 IF SYM = RPAREN THEN GETSYM ELSE ERROR(32)
16600 END
16700 end;
16800 procedure: level := lev;
16900 FUNCTION: LEVER := LEV
17000 end
17100 end
17200 end (*enter*);
17300
17400 function position(id: alfa): integer;
17500 var i: integer;
17600 begin (*find identifier id in table*)
17700 table[0].name :=id; i := tx;
17800 while table[i].name /= id do i := i-1;
17900 position := i
18000 end (*position*);
18100
18200 procedure constdeclaration;
18300 begin if sym = ident then
18400 begin getsym;
18500 if sym in [eql,becomes] then
18600 begin if sym = becomes then error(1);
18700 getsym;
18800 if sym = number then
18900 begin enter(constant); getsym
19000 end
19100 else error(2)
19200 end else error(3)
19300 end else error(4)
19400 end (*constdeclaration*);
19500
19600 procedure vardeclaration;
19700 begin if sym = ident then
19800 begin enter(variable) (*;GETSYM REMOVED FROM PROGRAM*)
19900 end else error(4)
20000 end (*vardeclaration*);
20100
20200 procedure listcode;
20300 var i: integer;
20400 begin (*list code generated for this block*)
20500 for i := cx0 to cx-1 do
20600 with code[i] do
20700 writeln(i,mnemonic[f]:5,l:3,a:5)
20800 end (*listcode*);
20900
21000 PROCEDURE LODVAR(V: INTEGER);
21100 WITH TABLE[V] DO
21200 IF LOW = HIGH THEN
21300 BEGIN GEN(LOD,LEV-LEVEL,ADR); GETSYM END
21400 ELSE
21500 BEGIN
21600 GETSYM;
21700 IF SYM = LPAREN THEN GETSYM ELSE ERROR(32);
21800 TEST(FACBEGSYS,FSYS,32);
21900 IF SYM IN FACBEGSYS THEN
22000 BEGIN
22100 EXPRESSION(FSYS);
22200 GEN(LIT,0,ADR-LOW);
22300 GEN(OPR,0,2);
22400 GEN(LDI,LEV-LEVEL,0)
22500 END;
22600 GETSYM;
22700 IF SYM = RPAREN THEN GETSYM ELSE ERROR(32)
22800 END;
22900
23000 PROCEDURE STOVAR(V: INTEGER);
23100 WITH TABLE[V] DO
23200 IF LOW = HIGH THEN
23300 BEGIN GEN(STO,LEV-LEVEL,ADR); GETSYM END
23400 ELSE
23500 BEGIN
23600 GETSYM;
23700 IF SYM = LPAREN THEN GETSYM ELSE ERROR(32);
23800 TEST(FACBEGSYS,FSYS,32);
23900 IF SYM IN FACBEGSYS THEN
24000 BEGIN
24100 EXPRESSION(FSYS);
24200 GEN(LIT,0,ADR-LOW);
24300 GEN(OPR,0,2);
24400 GEN(STI,LEV-LEVEL,0)
24500 END;
24600 GETSYM;
24700 IF SYM = RPAREN THEN GETSYM ELSE ERROR(32)
24800 END;
24900
25000 procedure statement(fsys:symset);
25100 var i,cx1,cx2,CX3,CX4: integer;
25200 procedure expression(fsys: symset);
25300 var addop: symbol;
25400 procedure term(fsys: symset);
25500 var mulop: symbol;
25600 PROCEDURE EXPON(FSYS: SYMSET);
25700 procedure factor(fsys: symset);
25800 var i: integer;
25900 begin test(facbegsys,fsys,24);
26000 while sym in facbegsys do
26100 begin
26200 if sym = ident then
26300 begin
26400 i := position(id);
26500 if i = 0 then error(11) else
26600 with table[i] do
26700 case kind of
26800 constant: BEGIN gen(lit,0,val); GETSYM END;
26900 variable: LODVAR(I);
27000 procedure: BEGIN error(21); GETSYM;
27100 TEST(FSYS,[],21)
27200 END;
27300 FUNCTION: BEGIN
27400 GEN(INT,0,1);
27500 IF NPARAM = 0 THEN GEN(CAL,LEV-LEVEL,ADR) ELSE
27600 BEGIN
27700 GETSYM;
27800 IF SYM = LPAREN THEN GETSYM ELSE ERROR(37);
27900 X := 0;
28000 REPEAT EXPRESSION([COMMA,RPAREN]+FSYS);
28100 X := X+1;
28200 WHILE SYM = COMMA DO
28300 BEGIN
28400 GETSYM;
28500 EXPRESSION([COMMA,RPAREN]+FSYS);
28600 X := X+1;
28700 END;
28800 IF SYM /= RPAREN THEN ERROR(5)
28900 UNTIL /(SYM IN FACBEGSYS);
29000 IF X /= NPARAM THEN ERROR(35);
29100 IF SYM = RPAREN THEN GETSYM ELSE ERROR(22);
29200 GEN(CAL,LEV-LEVEL,ADR)
29300 END;
29400 END;
29500 end;
29600 end else
29700 if sym = number then
29800 begin if num > amax then
29900 begin error(31); num := 0
30000 end;
30100 gen(lit,0,num); getsym
30200 end else
30300 if sym = lparen then
30400 begin getsym, expression([rparen]+fsys);
30500 if sym = rparen then getsym else error(22);
30600 end;
30700 test(fsys,[lparen],23)
30800 end
30900 end (*factor*);
31000 BEGIN (*expon*)
31100 FACTOR(FSYS+[EXP]);
31200 WHILE SYM = EXP DO
31300 BEGIN GETSYM; EXPON(FSYS+[TIMES,SLASH];
31400 GEN(OPR,0,14)
31500 END
31600 END (*expon*)
31700 begin (*term*)
31800 EXPON(fsys+[times,slash]);
31900 while sym in [times,slash] do
32000 begin mulop := sym; getsym; EXPON(fsys+[times,slash]);
32100 if mulop = times then gen(opr,0,4) else gen(opr,0,5)
32200 end
32300 end (*term*)
32400 begin (*expression*)
32500 if sym in [plus,minus] then
32600 begin addop := sym; getsym; term(fsys+[plus,minus]);
32700 if addop = minus then gen(opr,0,1)
32800 end else term(fsys+[plus,minus]);
32900 while sym in [plus,minus] do
33000 begin addop := sym; getsym; term(fsys+[plus,minus]);
33100 if addop = plus then gen(opr,0,2) else gen(opr,0,3)
33200 end
33300 end (*expression*)
33400
33500 begin (*statement*)
33600 if sym = ident then
33700 begin i := position(id);
33800 if i = 0 then error(11) else
33900 if table[i].kind /= variable then
34000 begin (*assignment to non-variable*) error(12); i := 0
34100 end;
34200 getsym; if sym = becomes then getsym else error(13);
34300 expression(fsys);
34400 if i /= 0 then
34500 STOVAR(I)
34600 end else
34700
34800 if sym = callsym then
34900 begin getsym;
35000 if sym /= ident then error(14) else
35100 begin i := position(id);
35200 if i = 0 then error(11) else
35300 with table[i] do
35400 if kind = procedure then
35500 IF NPARAM = 0 THEN GEN(CAL,LEV-LEVEL,ADR) ELSE
35600 BEGIN
35700 GETSYM;
35800 IF SYM = LPAREN THEN GETSYM ELSE ERROR(37);
35900 X := 0;
36000 REPEAT EXPRESSION([COMMA,RPAREN]+FSYS);
36100 X := X+1;
36200 WHILE SYM = COMMA DO
36300 BEGIN
36400 GETSYM;
36500 EXPRESSION([COMMA,RPAREN]+FSYS);
36600 X := X+1
36700 END;
36800 IF SYM /= RPAREN THEN ERROR(5)
36900 UNTIL /(SYM IN FACBEGSYS);
37000 IF X /= NPARAM THEN ERROR(35);
37100 IF SYM = RPAREN THEN GETSYM ELSE ERROR(22);
37200 GEN(CAL,LEV-LEVEL,ADR)
37300 END
37400 else error(15);
37500 getsym
37600 end
37700 end else
37800
37900 if sym = ifsym then
38000 begin
38100 getsym; condition([thensym,dosym]+fsys);
38200 if sym = thensym then getsym else error(16);
38300 cx1 := cx; gen(jpc,0,0);
38400 statement(fsys);
38500 IF SYM = ELSESYM THEN
38600 BEGIN
38700 CX2 :=CX; GEN(JMP,0,0);
38800 CODE[CX].A := CX;
38900 STATEMENT(FSYS); CODE[CX2].A := CX;
39000 END
39100 ELSE
39200 code[cx1].a := cx;
39300 end else
39400
39500 IF SYM = REPEATSYM THEN
39600 BEGIN
39700 CX1 := CX; GETSYM; STATEMENT([SEMICOLON,UNTILSYM]+FSYS);
39800 WHILE SYM IN [SEMICOLON]+STATBEGSYS DO
39900 BEGIN
40000 IF SYM = SEMICOLON THEN GETSYM ELSE ERROR(10);
40100 STATEMENT([SEMICOLON,UNTILSYM]+FSYS);
40200 END;
40300 IF SYM = UNTILSYM THEN GETSYM ELSE ERROR(31);
40400 CONDITION([SEMICOLON]+FSYS);
40500 GEN(JPC,0,CX1);
40600 END ELSE
40700
40800 IF SYS = FORSYM THEN
40900 BEGIN GETSYM;
41000 VARDECLARATION;
41100 I := POSITION[ID];
41200 IF SYM - BECOMES THEN GETSYM ELSE ERROR(32);
41300 EXPRESSION([TOSYM]+FSYS);
41400 STOVAR(I);
41500 CX1 := CX;
41600 LODVAR(I);
41700 IF SYM = TOSYM THEN GETSYM ELSE ERROR(33);
41800 EXPRESSION([BYSYM,DOSYM]+FSYS);
41900 GEN(OPR,0,13);
42000 CX2 := CX;
42100 GEN(JPC,0,0);
42200 CX3 := CX;
42300 GEN(JMP,0,0);
42400 CX4 := CX;
42500 IF SYM = BYSYM THEN
42600 BEGIN
42700 GETSYM;
42800 EXPRESSION([DOSYM]+FSYS);
42900 END ELSE
43000 GEN(LIT,0,1);
43100 LODVAR(I);
43200 GEN(OPR,0,2);
43300 STOVAR(I);
43400 GEN(JMP,0,CX1);
43500 CODE[CX2].A := CX;
43600 IF SYM = DOSYM THEN GETSYM ELSE ERROR(18);
43700 STATEMENT(FSYS);
43800 GEN(JMP,0,CX4);
43900 CODE[CX3].A := CX;
44000 END ELSE
44100
44200 IF SYM = READSYM THEN
44300 BEGIN GETSYM;
44400 IF SYM = LPAREN THEN GETSYM ELSE ERROR(34);
44500 REPEAT GEN(DIN,0,0);
44600 TEST(IDENT,FSYS+STATBEGSYS,34);
44700 IF SYM = IDENT THEN
44800 BEGIN
44900 I := POSITION(ID);
45000 IF I = 0 THEN ERROR(11) ELSE
45100 IF TABLE[I].KIND /= VARIABLE THEN
45200 BEGIN ERROR(12); I := 0
45300 END;
45400 IF I /= 0 THEN STOVAR(I)
45500 END;
45600 UNTIL SYM /= COMMA;
45700 IF SYM = RPAREN THEN GETSYM ELSE ERROR(34)
45800 END ELSE
45900
46000 IF SYM = WRITESYM THEN
46100 BEGIN GETSYM;
46200 IF SYM = LPAREN THEN GETSYM ELSE ERROR(35);
46300 REPEAT
46400 IF SYM IN FACBEGSYS THEN
46500 BEGIN EXPRESSION([COMMA,QUOTE]+FSYS);
46600 GEN(DOT,0,0)
46700 END
46800 ELSE
46900 IF SYM = QUOTE THEN
47000 BEGIN GETCH;
47100 WHILE CH /= QUOTE DO
47200 BEGIN
47300 GEN(LIT,0,CH);
47400 GEN(DOT,0,0);
47500 GETCH
47600 END;
47700 GETSYM
47800 END
47900 UNTIL /(SYM IN [COMMA,QUOTE]+FACBEGSYS);
48000 IF SYM = RPAREN THEN GETSYM ELSE ERROR(34);
48100 END ELSE
48200
48300 if sym = beginsym then
48400 begin getsym; statement([semicolon,endsym]+fsys);
48500 while sym in [semicolon]+statbegsys do
48600 begin
48700 if sym = semicolon then getsym else error(10);
48800 statement([semicolon,endsym]+fsys)
48900 end;
49000 if sym = endsym the getsym else error(17)
49100 end else
49200
49300 if sym = whilesym then
49400 begin cx1 := cx; getsym; condition([dosym]+fsys);
49500 cx2 := cx; gen(jpc,0,0);
49600 if sym = dosym then getsym else error(18);
49700 statement(fsys); gen(jmp,o,cx1); code[cx2].a := cx
49800 end;
49900 test(fsys,[],19)
50000 end (*statement*) ;
50100
50200 begin (*block*) dx := 3; tx0 := tx; table [tx].adr := cx; gen(jmp,0,0);
50300 if lev > levmax then error(32);
50400 repeat
50500 if sym = constsym then
50600 begin getsym;
50700 while sym = comma do
50800 begin getsym; constdeclaration
50900 end;
51000 if sym = semicolon then getsym else error(5)
51100 until sym /= ident
51200 end;
51300
51400 if sym = varsym then
51500 begin getsym;
51600 repeat vardeclaration;
51700 while sym = comma do
51800 begin getsym; vardeclaration
51900 end;
52000 if sym = semicolon then getsym else error(5)
52100 until sym /= ident
52200 end;
52300
52400 while sym = procsym do
52500 begin getsym;
52600 if sym = ident then
52700 begin enter(procedure); getsym; I := POSITION(ID)
52800 end
52900 else BEGIN error(4); I := 0 END;
53000 IF SYM /= LPAREN THEN BEGIN IF I /= 0 THEN WITH TABLE[I] DO NPARAM := 0 END
53100 ELSE
53200 BEGIN
53300 GETSYM; DX0 := DX;
53400 IF SYM = CONST THEN
53500 BEGIN
53600 IF I /= 0 THEN
53700 BEGIN
53800 WITH TABLE[I] DO NPARAM := NUM;
53900 DX := -NUM
54000 END;
54100 GETSYM
54200 END
54300 ELSE
54400 BEGIN
54500 ERROR(36);
54600 TEST([COMMA],FSYS+[RPAREN],36)
54700 END;
54800 WHILE SYM = COMMA DO
54900 BEGIN GETSYM; VARDECLARATION
55000 END;
55100 IF DX /= 0 THEN ERROR(35);
55200 DX := DX0;
55300 IF SYM = RPAREN THEN GETSYM ELSE ERROR(22);
55400 END;
55500 if sym = semicolon then getsym else error(5);
55600 block(lev+1,tx,[semicolon]+fsys);
55700 if sym = semicolon then
55800 begin getsym; test(statbegsys+[ident,procsym],fsys,6)
55900 end
56000 else error(5)
56100 end;
56200
56300 WHILE SYM = FUNCTSYM DO
56400 BEGIN GETSYM;
56500 DX0 := DX;
56600 IF SYM = IDENT THEN
56700 BEGIN
56800 ENTER(FUNCTION);
56900 I := POSITION(ID);
57000 DX := -1;
57100 VARDECLARATION;
57200 I1 := POSITION(ID);
57300 END
57400 ELSE BEGIN ERROR(4); I := 0 END;
57500 IF SYM /= LPAREN THEN BEGIN IF I /= 0 THEN WITH TABLE[I] DO NPARAM := 0 END
57600 ELSE
57700 BEGIN
57800 GETSYM;
57900 IF SYM = CONST THEN
58000 BEGIN
58100 IF I /= 0 THEN
58200 BEGIN
58300 WITH TABLE[I] DO NPARAM := NUM;
58400 WITH TABLE[I1] DO ADR := -NUM;
58500 DX := -NUM
58600 END;
58700 GETSYM
58800 END
58900 ELSE
59000 BEGIN
59100 ERROR(36);
59200 TEST([COMMA],FSYS+[RPAREN],36)
59300 END;
59400 WHILE SYM = COMMA DO
59500 BEGIN GETSYM; VARDECLARATION
59600 END;
59700 IF DX /= 0 THEN ERROR(35);
59800 IF SYM = RPAREN THEN GETSYM ELSE ERROR(22);
59900 END;
60000 DX := DX0;
60100 IF SYM = SEMICOLON THEN GETSYM ELSE ERROR(5);
60200 BLOCK(LEV+1MTXM[SEMICOLON]+FSYS);
60300 IF SYM = SEMICOLON THEN
60400 BEGIN GETSYM; TEST(STATBEGSYS+[IDENT,FUNCTSYM],FSYS,6)
60500 END
60600 ELSE ERROR(5)
60700 END;
60800
60900 test(statbegsys+[ident],declbegsys,7)
61000 until /(sym in declbegsys);
61100
61200 code[table[tx0].adr].a := cx;
61300 with table[tx0] do
61400 begin adr := cx; (*start address of code*)
61500 size := dx; (*size of data segment*)
61600 end;
61700
61800 cx0 := cx; gen(int,0,dx);
61900 statement([semicolon,endsym]+fsys);
62000 gen(opr,0,0); (*return*)
62100 test(fsys,[],8);
62200 listcode;
62300 end (*block*);
62400
62500
62600 procedure interpret;
62700 const stacksize = 500;
62800 var p,b,t: integer (*program-,base-,topstack-registers*)
62900 i: instruction; (*instruction register*)
63000 s:array[1..stacksize] of integer; (*datastore*)
63100 function base(l: integer): integer;
63200 var b1: integer;
63300 begin b1 := b; (*find base l levels down*)
63400 while l > 0 do
63500 begin b1 := s[b1]; l := l - 1
63600 end;
63700 base := b1;
63800 end (*base*);
63900 begin writeln('start pl/o');
64000 t := 0; b := 1; p := 0;
64100 s[1] := 0; s[2] := 0; s[3] := 0;
64200 repeat i := code[p]; p := p + 1;
64300 with i do
64400 case f of
64500
64600 lit: begin t := t + 1; s[t] := a;
64700 end;
64800 opr: case a of (*operator*)
64900 0: begin (*return*)
65000 t := b-1; p := s[t+3]; b := s[t+2];
65100 end;
65200
65300 1: s[t] := -s[t];
65400
65500 2: begin t := t-1; s[t] := s[t] + s[t+1];
65600 end;
65700
65800 3: begin t := t-1; s[t] := s[t] - s[t+1];
65900 end;
66000
66100 4: begin t := t-1; s[t] := s[t] * s[t+1];
66200 end;
66300
66400 5: begin t := t-1; s[t] := s[t] / s[t+1];
66500 end;
66600
66700 6: s[t] := ord(odd(s[t]));
66800
66900 8: begin t := t-1; s[t] := ord(s[t] = s[t+1]);
67000 end;
67100
67200 9: begin t := t-1; s[t] := ord(s[t] /= s[t+1]);
67300 end;
67400
67500 10: begin t := t-1; s[t] := ord(s[t] < s[t+1]);
67600 end;
67700
67800 11: begin t := t-1; s[t] := ord(s[t] >= s[t+1]);
67900 end;
68000
68100 12: begin t := t-1; s[t] := ord(s[t] > s[t+1];
68200 end;
68300
68400 13: begin t := t-1; s[t] := ord(s[t] =< s[t+1]);
68500 end;
68600
68700 14: BEGIN T := T-1; S[T] := S[T] ↑ S[T+1];
68800 END;
68900
69000 end;
69100
69200 lod: begin t:= t+1; s[t] := s[base(l)+a]
69300 end;
69400
69500 sto: begin s[base(l)+a] := s[t]; writeln(s[t]); t := t-1
69600 end;
69700
69800 cal: begin (*generate new block mark*)
69900 s[t+1] := base(l); s[t+2] := b; s[t+3] := p;
70000 b := t+1; p := 1
70100 end;
70200
70300 int: t := t+a;
70400
70500 jmp: p := a;
70600
70700 jpc: begin if s[t] = 0 then p := a; t := t-1;
70800 end
70900
71000 LDI: S[T] := S[BASE(L)+S[T]];
71100
71200 STI: BEGIN S[BASE(L)+S[T]] := S[T-1]; T := T-2
71300 END;
71400
71500 DIN: BEGIN T := T+1; S[T] := <INPUT>
71600 END;
71700
71800 DOT: BEGIN <OUTPUT> := S[T]; T := T-1
71900 END;
72000
72100 end (*with,case*)
72200 until p = 0;
72300 write('end pl/0');
72400 end (*interpret];
72500
72600 begin (*main program*)
72700 for ch := 'a' to ';' do ssym[ch] := nul;
72800 word[1] := 'begin'; word[2] := 'call ';
72900 word[3] := 'const'; word[4] := 'do ';
73000 word[5] := 'end '; word[6] := 'if ';
73100 word[7] := 'odd '; word[8] := 'procedure';
73200 word[9] := 'then '; word[10] := 'var ';
73300 word[11] := 'while'; WORD[12] := 'ELSE ';
73400 WORD[13] := 'REPEAT'; WORD[14] := 'UNTIL';
73500 WORD[15] := 'FOR '; WORD[16] := 'TO';
73600 WORD[17] := 'BY '; WORD[18] := 'WRITE';
73700 WORD[19] := 'READ '; WORD[20] := 'FUNCTION';
73800
73900 wsym[ 1] := beginsym; wsym[ 2] := callsym;
74000 wsym[ 3] := constsym; wsym[ 4] := dosym;
74100 wsym[ 5] := endsym; wsym[ 6] := ifsym;
74200 wsym[ 7] := oddsym; wsym[ 8] := procsym;
74300 wsym[ 9] := thensym; wsym[10] := varsym;
74400 wsym[11] := whilesym; WSYM[12] := ELSESYM;
74500 WSYM[13] := REPEATSYM; WSYM[14] := UNTILSYM;
74600 WSYM[15] := FORSYM; WSYM[16] := TOSYM;
74700 WSYM[17] := BYSYM; WSYM[18] := WRITESYM;
74800 WSYM[19] := READSYM; WSYM[20] := FUNCTSYM;
74900
75000 ssym['+'] := plus; ssym['-'] := minus;
75100 ssym['*'] := times; ssym['/'] := slash;
75200 ssym['('] := lparen; ssym[')'] := rparen;
75300 ssym['='] := eql; ssym['/='] := neq;
75400 ssym['.'] := period; ssym[','] := comma;
75500 ssym['<'] := lss; ssym['>'] := gtr;
75600 ssym['=<'] := leq; ssym['>='] := geq;
75700 ssym[';'] := semicolon; SSYM['↑'] := EXP;
75800 SSYM[':'] := COLON; SSYM['''] := QUOTE;
75900
76000 mnemonic[lit] := 'lit'; mnemonic[opr] := 'opr';
76100 mnemonic[lod] := 'lod'; mnemonic[sto] := 'sto';
76200 mnemonic[cal] := 'cal'; mnemonic[int] := 'int';
76300 mnemonic[jmp] := 'jmp'; mnemonic[jpc] := 'jpc';
76400 MNEMONIC[DIN] := 'DIN'; MNEMONIC[DOT] := 'DOT';
76500 MNEMONIC[LDI] := 'LDI'; MNEMONIC[STI] := 'STI';
76600
76700 declbegsys := [constsym,varsym,procsym,FUNCTSYM];
76800 statbegsys := [beginsym,callsym,ifsym,whilesym,REPEATSYM,FORSYM,WRITESYM,READSYM];
76900 facbegsys := [ident,number,lparen];
77000 page(output);
77100 cc:= 0; cx := 0; ll := 0; ch := ''; kk := al; getsym;
77200 block(0,0,[period]+declbegsys+statbegsys);
77300 if sym /= perion then error(9);
77400 if err = 0 then interpret else write('errors in pl/0 program');
77500 99: writeln
77600 end.